#lang scheme

(provide bytes-compare
         subbytes-compare

         bytes-prefix? bytes-prefix-ci?
         bytes-suffix? bytes-suffix-ci?

         build-bytes

         bytes-null?

         bytes->symbol/latin-1
         symbol->bytes/latin-1
         number->bytes
         bytes->number
         bytes-index
         bytes-index-right
         bytes-split string-split
         bytes-split-words-rev
         bytes-split-words
         bytes-map
         bytes-count
         ;         is-digit
         byte-numeric?
         byte-lower-case?
         byte-upper-case?
         byte-alphabetic?
         byte-symbolic?
         byte-punctuation?
         byte-whitespace?
         byte-blank?
         byte-iso-control?
         byte-graphic?

         bytes-strip bytes-lstrip bytes-rstrip

         byte-ci=?
         byte-upcase   bytes-upcase
         byte-downcase bytes-downcase
         bytes-first   bytes-last
         string-first  string-last

         bytes->string/utf-16
         string->bytes/utf-16

        bytes-join-not-empty
        bytes<=?
        bytes>=?
        bytes-ci=? ; reexport from unstable/bytes

         bin oct hex) ; python's number->string with radix 2,8,16

(require  rnrs/bytevectors-6
          unstable/bytes
          ;rnrs/arithmetic/fixnums-6
          (only-in srfi/13 string-index string-count)
          srfi/2
          srfi/67 ; for integer-compare, if3
          "test.ss"
          "tidbits.ss")


(define bytes<=? (negate bytes>?))
(define bytes>=? (negate bytes<?))

(define (bytes-null? bstr)
  (equal? bstr #""))

(define (bin x)
  (string-append "0b" (number->string x 2)))
(define (oct x)
  (string-append "0" (number->string x 8)))
(define (hex x)
  (string-append "0x" (number->string x 16)))

(equal! (bin 666) "0b1010011010")
(equal! (oct 666) "01232")
(equal! (hex 666) "0x29a")

(define (build-bytes n proc)
  (let ([bv (make-bytes n)])
    (dotimes (i n)
             (bytes-set! bv i (proc i)))
    bv))

(define (subbytes-compare a b
                          [a-start 0] [a-end (bytes-length a)]
                          [b-start 0] [b-end (bytes-length b)])
  (let loop ([ai a-start]
             [bi b-start])
    (if (= ai a-end) ; TODO: if4 ?
        (if (= bi b-end)
            0
            -1)
        (if (= bi b-end)
            1
            (if3 (integer-compare (bytes-ref a ai)
                                  (bytes-ref b bi))
                 -1
                 (loop (+ 1 ai) (+ 1 bi))
                 1)))))

(define (bytes-compare a b)
  (cond
    [(bytes<? a b) -1]
    [(bytes<? b a) 1]
    [else 0]))

;(subbytes-compare #"EDU CRANBROOKART" #"EDU CRANBROOK")
;(bytes-compare #"EDU CRANBROOKART" #"EDU CRANBROOK")
;(exit)

(define (bytes-prefix-length elteq? a b
                             [a-start 0] [a-end (bytes-length a)]
                             [b-start 0] [b-end (bytes-length b)])
  (let* ((delta (min (- a-end a-start) (- b-end b-start)))
         (a-end (+ a-start delta)))
    (if (and (eq? a b) (= a-start b-start)) ; EQ fast path
        delta
        (let loop ((i a-start) (j b-start)) ; Regular path
          (if (or (>= i a-end)
                  (not (elteq? (bytes-ref a i)
                               (bytes-ref b j))))
              (- i a-start)
              (loop (+ i 1) (+ j 1)))))))

(define (bytes-suffix-length elteq? a b
                             [a-start 0] [a-end (bytes-length a)]
                             [b-start 0] [b-end (bytes-length b)])
  (let* ((delta (min (- a-end a-start) (- b-end b-start)))
         (a-start (- a-end delta)))
    (if (and (eq? a b) (= a-end b-end)) ; EQ fast path
        delta
        (let loop ((i (- a-end 1)) (j (- b-end 1))) ; Regular path
          (if (or (< i a-start)
                  (not (elteq? (bytes-ref a i)
                               (bytes-ref b j))))
              (- a-end i 1)
              (loop (- i 1) (- j 1)))))))

; is a prefix of b
(define (bytes-prefix? a b
                       [a-start 0] [a-end (bytes-length a)]
                       [b-start 0] [b-end (bytes-length b)])
  (let ([a-len (- a-end a-start)]
        [b-len (- a-end a-start)])
    (and (<= a-len b-len)    ; Quick check
         (= a-len (bytes-prefix-length = a b a-start a-end b-start b-end)))))

; is a suffix of b
(define (bytes-suffix? a b
                       [a-start 0] [a-end (bytes-length a)]
                       [b-start 0] [b-end (bytes-length b)])
  (let ([a-len (- a-end a-start)]
        [b-len (- a-end a-start)])
    (and (<= a-len b-len)    ; Quick check
         (= a-len (bytes-suffix-length = a b a-start a-end b-start b-end)))))

; is a prefix of b
(define (bytes-prefix-ci? a b
                       [a-start 0] [a-end (bytes-length a)]
                       [b-start 0] [b-end (bytes-length b)])
  (let ([a-len (- a-end a-start)]
        [b-len (- a-end a-start)])
    (and (<= a-len b-len)    ; Quick check
         (= a-len (bytes-prefix-length byte-ci=? a b a-start a-end b-start b-end)))))

; is a suffix of b
(define (bytes-suffix-ci? a b
                       [a-start 0] [a-end (bytes-length a)]
                       [b-start 0] [b-end (bytes-length b)])
  (let ([a-len (- a-end a-start)]
        [b-len (- a-end a-start)])
    (and (<= a-len b-len)    ; Quick check
         (= a-len (bytes-suffix-length byte-ci=? a b a-start a-end b-start b-end)))))



(define (bytes->symbol/latin-1 bstr)
  (string->symbol (bytes->string/latin-1 bstr)))

(define (symbol->bytes/latin-1 bstr)
  (string->bytes/latin-1 (symbol->string bstr)))



(eq! 'cons
     (bytes->symbol/latin-1 #"cons")
     (string->symbol "cons"))

(define (number->bytes n [radix 10])
  (string->bytes/latin-1 (number->string n radix)))

(define (bytes->number bstr [radix 10])
  (string->number (bytes->string/latin-1 bstr) radix))

; string-index for bytes
(define (bytes-index bstr b [start 0] [end (bytes-length bstr)])
  (let loop ([i start])
    (cond [(>= i end) #f]
          [(= b (bytes-ref bstr i)) i]
          [else (loop (add1 i))])))
(eq! (bytes-index #"HELLO" (char->integer #\E)) 1)
(eq! (bytes-index #"HELLO" (char->integer #\L)) 2)
(eq! (bytes-index #"HELLO" (char->integer #\W)) #f)

(define (bytes-index-right bstr b [start 0] [end (bytes-length bstr)])
  (let loop ([i (sub1 end)])
    (cond [(< i start) #f]
          [(= b (bytes-ref bstr i)) i]
          [else (loop (sub1 i))])))
(eq! (bytes-index-right #"HELLO" (char->integer #\E)) 1)
(eq! (bytes-index-right #"HELLO" (char->integer #\L)) 3)
(eq! (bytes-index-right #"HELLO" (char->integer #\W)) #f)


(define (bytes-join-not-empty separator . fragments)
  (foldl (lambda (n p) ; or foldr
           (cond [(bytes-null? n) p]
                 [(bytes-null? p) n]
                 ; [(eq? (string-ref n 0) #\/) (string-append p n)]
                 ; [(eq? (string-ref p (- (string-length p) 1)) #\/) (string-append p n)]
                 [else (bytes-append p separator n)]))
         #""
         fragments))

; TODO: if n is set, always returns list of length n, even if it supposed to be shorter
; split bytes to max _n_ parts, using byte _separator_
(define (bytes-split bstr [separator #x20] [n 0])
  (if (= n 1)
      (list bstr)
      (let ([pos (bytes-index bstr separator)])
        (if pos
            (cons (subbytes bstr 0 pos)
                  (bytes-split (subbytes bstr (+ 1 pos)) separator (- n 1)))
            (cons bstr null)))))

; TODO: wrapper for string-tokenize?
(define (string-split str [separator #\space] [n 0])
  (if (= n 1)
      (list str)
      (let ([pos (string-index str separator)])
        (if pos
            (cons (substring str 0 pos)
                  (string-split (substring str (+ 1 pos)) separator (- n 1)))
            (cons str null)))))

(equal! (bytes-split #"HELLO WORLD")
        (bytes-split #"HELLO!WORLD" #x21)
        (bytes-split #"HELLORWORLD" (char->integer #\R) 2)
        '(#"HELLO" #"WORLD"))
(equal! (bytes-split #" HELLO   WORLD ")
        '(#"" #"HELLO" #"" #"" #"WORLD" #""))

; split bytestring to words (also bytestrings)
(define (bytes-split-words-rev bstr
                               [separator 'spaces]) ; [is-space (lambda(c) (<= c 32))])
  (define is-space
    (if (eq? separator 'spaces)
        (lambda (c) (<= c 32))
        (lambda (c) (= c separator))))
  (define len (bytes-length bstr))
  (let loop ([begin 0][end 0][lst '()])
    (if (= end len)
        (if (= begin end) lst (cons (subbytes bstr begin end) lst))
        (let ([c (bytes-ref bstr end)])
          (if (is-space c)
              (loop (+ 1 end) (+ 1 end)
                    (if (= begin end) lst (cons (subbytes bstr begin end) lst)))
              (loop begin (+ 1 end) lst))))))

(define (bytes-split-words bstr
                           [separator 'spaces]) ; [is-space (lambda(c) (<= c 32))]
  (define is-space
    (if (eq? separator 'spaces)
        (lambda (c) (<= c 32))
        (lambda (c) (= c separator))))
  (define len (bytes-length bstr))
  (let loop ([begin len][end len][lst '()])
    (if (= begin 0)
        (if (= begin end) lst (cons (subbytes bstr begin end) lst))
        (let ([c (bytes-ref bstr (- begin 1))])
          (if (is-space c)
              (loop (- begin 1) (- begin 1)
                    (if (= begin end) lst (cons (subbytes bstr begin end) lst)))
              (loop (- begin 1) end lst))))))

(equal! (bytes-split-words #"www.yahoo.com" (char->integer #\.))
        '(#"www" #"yahoo" #"com"))
(equal! (bytes-split-words-rev #"www.yahoo.com" (char->integer #\.))
        '(#"com" #"yahoo" #"www"))


(define (bytes-count bstr b [start 0] [end (bytes-length bstr)])
  (let loop ([c 0] [start start])
    (cond [(>= start end) c]
          [(= b (bytes-ref bstr start)) (loop (add1 c) (add1 start))]
          [else (loop c (add1 start))])))

(define (bytes-map f bstr)
  (let* ([len (bytes-length bstr)]
         [x (make-bytes len)])
    (let loop ([i 0])
      (if (>= i len)
          x
          (begin (bytes-set! x i (f (bytes-ref bstr i)))
                 (loop (add1 i)))))))

(define (byte-numeric? b)
  (<= #x30 b #x39))

(define (byte-lower-case? b)
  (<= (char->integer #\a) b (char->integer #\z)))

(define (byte-upper-case? b)
  (<= (char->integer #\A) b (char->integer #\Z)))

(define (byte-alphabetic? b)
  (<= (char->integer #\A) (bitwise-ior b #x20) (char->integer #\Z)))

; TODO: make table
; 36 43 60 61 62 94 96 124 126
;  $  +  <  =  >  ^  `   |   ~
(define (byte-symbolic? b)
  (char-symbolic? (integer->char b)))

; 33 34 35 37 38 39 40 41 42 44 45 46 47 58 59 63 64 91 92 93 95 123 125
;  !  "  #  %  &  '  (  )  *  ,  -  .  /  :  ;  ?  @  [  \  ]  _   {   }
(define (byte-punctuation? b)
  (char-punctuation? (integer->char b)))

; 9 #\tab
;10 #\newline
;11 #\vtab
;12 #\page
;13 #\return
;32 #\space
(define (byte-whitespace? b)
  (or (= #x20 b)
      (<= #x09 b #x0D)))

; 9 #\tab
;32 #\space
(define (byte-blank? b)
  (or (= #x20 b) (= #x09 b)))

(define (byte-iso-control? b)
  (or (< b #x20) (= #x7F b)))

(define (byte-graphic? b)
  (<= #x21 b #x7E))


(define (byte-upcase b)
  (if (<= #x61 b #x7A) (- b #x20) b))

(define (bytes-upcase bstr)
  (bytes-map byte-upcase bstr))

(equal! (bytes-upcase #"bsTr") #"BSTR")

(define (byte-downcase b)
  (if (<= #x41 b #x5A) (+ b #x20) b))

(define (bytes-downcase bstr)
  (bytes-map byte-downcase bstr))

(define (byte-ci=? a b)
    (= (byte-upcase a) (byte-upcase b)))

(define (bytes-first bstr)
  (bytes-ref bstr 0))

(define (bytes-last bstr)
  (bytes-ref bstr (- (bytes-length bstr) 1)))

(define (string-first bstr)
  (string-ref bstr 0))

(define (string-last str)
  (string-ref str (- (string-length str) 1)))

(define (bytes-lstrip bstr
                      [pred byte-whitespace?]
                      [start 0]
                      [end (bytes-length bstr)])
  (let loop ([start start] [end end])
    (cond [(>= start end) #""]
          [(pred (bytes-ref bstr start)) (loop (add1 start) end)]
          [else (subbytes bstr start end)])))

(define (bytes-rstrip bstr
                      [pred byte-whitespace?]
                      [start 0]
                      [end (bytes-length bstr)])
  (let loop ([start start] [end end])
    (cond [(>= start end) #""]
          [(pred (bytes-ref bstr (sub1 end))) (loop start (sub1 end))]
          [else (subbytes bstr start end)])))

(define (bytes-strip bstr
                      [pred byte-whitespace?]
                      [start 0]
                      [end (bytes-length bstr)])
  (let loop ([start start] [end end])
    (cond [(>= start end) #""]
          [(pred (bytes-ref bstr start)) (loop (add1 start) end)]
          [(pred (bytes-ref bstr (sub1 end))) (loop start (sub1 end))]
          [else (subbytes bstr start end)])))

; TODO: endianess

(define (string->bytes/utf-16 str [_ #f] [start 0] [end (string-length str)])
  (let* ([extra (string-count str
                              (lambda(c) (<= #x010000 (char->integer c)))
                              start
                              end)]
         [bstr (make-bytes (* 2 (+ extra (- end start))))])
    (let loop ([i start] [j 0])
      (if (< i end)
          (let ([ch (char->integer (string-ref str i))])
            (cond ;[(< #x00D7FF i #x00E000) (error "string->bytes/utf-16: invalid char")] ; must not be
              [(< ch #x010000)
               (bytevector-u16-native-set! bstr j ch)
               (loop (+ 1 i) (+ 2 j))]
              [else
                (bytevector-u16-native-set! bstr j (+ #xD800 (bitwise-bit-field (- ch #x10000) 10 20)))
                (bytevector-u16-native-set! bstr (+ 2 j) (+ #xDC00 (bitwise-bit-field ch 0 10)))
                (loop (+ 1 i) (+ 4 j))]))
          bstr))))

(define (bytes->string/utf-16-length bstr [err-char #f] [start 0] [end (bytes-length bstr)])
  (when (and (not err-char) (odd? (- end start)))
    (error "bytes->string/utf-16: odd length"))
  ;  (o (quotient (- end start -1) 2))
  (let loop ([i start] [strlen (quotient (- end start -1) 2)])
    (if (<= (+ 2 i) end)
        (let ([ch (bytevector-u16-native-ref bstr i)])
          (cond
            [(or (< ch #xD800) (< #xDFFF ch))
             (loop (+ 2 i) strlen)]
            [(<= #xDC00 ch #xDFFF)
             (if err-char
                 (loop (+ 2 i) strlen)
                 (error "bytes->string/utf-16:" ch))]
            ;[(<= #xD800 ch #xDBFF)
            [(> (+ i 4) end) ; no space for the second char
             (if err-char
                 (loop (+ 2 i) strlen)
                 (error "bytes->string/utf-16: no space after " ch))]
            [(and-let* ([ch2 (bytevector-u16-native-ref bstr (+ 2 i))]
                        [(not (<= #xDC00 ch2 #xDFFF))])
                       (if err-char
                           (loop (+ 2 i) strlen)
                           (error "bytes->string/utf-16: " ch ch2)))]
            [else
              ;              (o (sub1 strlen))
              (loop (+ 4 i) (sub1 strlen))]))
        strlen)))

;exn:fail:contract
(define (bytes->string/utf-16 bstr [err-char #f] [start 0] [end (bytes-length bstr)])
  ; first pass: measure length and check for errors
  (let ([str (make-string (bytes->string/utf-16-length bstr err-char start end))])
    ; second pass
    (let loop ([i start] [j 0])
      (cond
        [(= i end) str]
        [(= (+ 1 i) end) (true! err-char)
                         (string-set! str j err-char)
                         str]
        [else (let ([ch (bytevector-u16-native-ref bstr i)])
                (cond
                  [(or (< ch #xD800) (< #xDFFF ch))
                   (string-set! str j (integer->char ch))
                   (loop (+ 2 i) (+ 1 j))]
                  [(<= #xDC00 ch #xDFFF)
                   (true! err-char) ; otherwise there would be an exception in bytes->string/utf-16-length
                   (string-set! str j err-char)
                   (loop (+ 2 i) (+ 1 j))]
                  [(> (+ i 4) end) ; no space for the second char
                   (true! err-char)
                   (string-set! str j err-char)
                   (loop (+ 2 i) (+ 1 j))]
                  [(and-let* ([ch2 (bytevector-u16-native-ref bstr (+ 2 i))]
                              [(<= #xDC00 ch2 #xDFFF)])
                             (string-set! str j
                                          (integer->char
                                           (+ #x10000
                                              (arithmetic-shift (- ch #xD800) 10)
                                              (- ch2 #xDC00))))
                             (loop (+ 4 i) (+ 1 j)))]
                  [else
                    (true! err-char)
                    (string-set! str i err-char)
                    (loop (+ 2 i) (+ 1 j))]))]))))

; +TEST
#| |#
(define pass-string (compose bytes->string/utf-16 string->bytes/utf-16))

(equal! (pass-string (string #\U64321 #\space #\!))
        (string #\U64321 #\space #\!))
(equal! (pass-string (string ))
        (string ))
(equal! (pass-string (string #\U64321 #\U1D11E #\U64321 #\nul #\U10FFFF))
        (string #\U64321 #\U1D11E #\U64321 #\nul #\U10FFFF))

(equal! (bytes->string/utf-16 (bytes) #\!)
        "")
(equal! (bytes->string/utf-16 (bytes 0) #\!)
        "!")
(equal! (bytes->string/utf-16 (bytes 0 0) #\!)
        "\0")
(equal! (bytes->string/utf-16 (bytes 0 0 0) #\!)
        "\0!")
(equal! (bytes->string/utf-16 (bytes 0 0 0 0) #\!)
        "\0\0")

(equal! (bytes->string/utf-16 (bytes #xD9) #\!)
        (bytes->string/utf-16 (bytes #x50 #xD9) #\!)
        (bytes->string/utf-16 (bytes #x21 #xDF) #\!)
        "!")
(equal! (bytes->string/utf-16 (bytes #x21 #xDF #x21 #xDF) #\!)
        (bytes->string/utf-16 (bytes #x21 #xDF #x50 #xD9) #\!)
        (bytes->string/utf-16 (bytes #x50 #xD9 #x50) #\!)
        "!!")
(equal! (bytes->string/utf-16 (bytes #x50 #xD9 #x50 #x00) #\!)
        "!P")
(equal! (bytes->string/utf-16 (bytes #x21 #xDF #x50 #xD9 #x00) #\!)
        "!!!")
(equal! (bytes->string/utf-16 (bytes #x50 #xD9 #x21 #xDF) #\!)
        (bytes->string/utf-16 (bytes 0 #x50 #xD9 #x21 #xDF) #\! 1)
        (bytes->string/utf-16 (bytes 0 #x50 #xD9 #x21 #xDF 0 0) #\! 1 5)
        (string #\U64321))
#| |#
; -TEST

;;;;;;;;;;
(define (reverse-domain bstr sepa [new-sepa sepa] [origin #""])
  (if (bytes-null? bstr)
      bstr
      (let* ([sepa-@end (= sepa (bytes-last bstr))]
             [len (if sepa-@end (sub1 (bytes-length bstr)) (bytes-length bstr))]
             [origin-len (if sepa-@end 0 (bytes-length origin))]
             [origin+sepa-len (if (zero? origin-len) 0 (add1 origin-len))]
             [target (make-bytes (+ origin+sepa-len len))])
        (unless (zero? origin-len)
          (bytes-copy! target 0 origin)
          (bytes-set! target origin-len new-sepa))
        (let loop ([i len] [q origin+sepa-len])
          (let ([j (bytes-index-right bstr sepa 0 i)])
            (if j
                (begin
                  (bytes-copy! target q bstr (add1 j) i)
                  (bytes-set! target (+ q (- i j 1)) new-sepa)
                  (loop j (+ q (- i j))))
                (begin
                  (bytes-copy! target q bstr 0 i)
                  target)))))))

; proc is upcase, or like
(define (reverse-domain* proc bstr sepa [new-sepa sepa] [origin #""])

  (define (bytes-copy!* dest dest-start src src-start src-end)
    (do ([isrc src-start (add1 isrc)]
         [idest dest-start (add1 idest)])
      ((>= isrc src-end) )
      (bytes-set! dest idest (proc (bytes-ref src isrc)))))

  (if (bytes-null? bstr)
      bstr
      (let* ([sepa-@end (= sepa (bytes-last bstr))]
             [len (if sepa-@end (sub1 (bytes-length bstr)) (bytes-length bstr))]
             [origin-len (if sepa-@end 0 (bytes-length origin))]
             [origin+sepa-len (if (zero? origin-len) 0 (add1 origin-len))]
             [target (make-bytes (+ origin+sepa-len len))])
        (unless (zero? origin-len)
          (bytes-copy! target 0 origin)
          (bytes-set! target origin-len new-sepa))
        (let loop ([i len] [q origin+sepa-len])
          (let ([j (bytes-index-right bstr sepa 0 i)])
            (if j
                (begin
                  (bytes-copy!* target q bstr (add1 j) i)
                  (bytes-set! target (+ q (- i j 1)) new-sepa)
                  (loop j (+ q (- i j))))
                (begin
                  (bytes-copy!* target q bstr 0 i)
                  target)))))))

(provide bytes->domkey
         domkey->bytes)

(define (bytes->domkey bstr [origin #""])
  (reverse-domain* byte-upcase
                   bstr
                   (char->integer #\.)
                   (char->integer #\space)
                   origin))

(define (domkey->bytes bstr)
  (reverse-domain bstr
                  (char->integer #\space)
                  (char->integer #\.)))


#|
(bytes->domkey #"yandex" #"ru")
(bytes->domkey #"yandex." #"ru")

(bytes->domkey #"Ru")
(bytes->domkey #"www.YANDEX.Ru")
(bytes->domkey #"Ru.")
(bytes->domkey #"www.YANDEX.Ru.")
(bytes->domkey #"")
(bytes->domkey #".")

;(domkey->bytes (bytes->domkey #"Ru"))
;(domkey->bytes (bytes->domkey #"www.YANDEX.Ru"))
;(domkey->bytes (bytes->domkey #"Ru."))
;(domkey->bytes (bytes->domkey #"www.YANDEX.Ru."))

|#

;  )
